home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / Janim / anim_iff.f < prev    next >
Encoding:
FORTH Source  |  1992-01-28  |  7.0 KB  |  350 lines
  1. \ ANIM support for JForth, read and write IFF ANIM files.
  2. \
  3. \ Utility for ANIM-5 support in JForth
  4. \ that adds to Phil Burk's IFF files
  5. \ in an integrated manner.
  6. \
  7. \ Author: Martin Kees    10/13/90
  8. \ Copyright: 1990 Martin Kees
  9. \ Freely distributable to the JForth Community
  10.  
  11. \ MOD: MCK 11/5/90 need @ in $ANIM.LOAD after $anim-file
  12. \ MOD: MCK 11/5/90 more info in error meesage in $anim.load
  13. \ MOD: MCK 11/5/90 added an_CAMG item in anim.load for easier save
  14. \ MOD: MCK 11/10/90 added anim.display to be able to cycle anim hidden
  15. \ MOD: MCK 11/21/90 added anim-dpan structure
  16. \ MOD: MCK 2/11-91  ANIM-ERROR changes
  17. \ 00001 PLB 9/5/91 Disabled ANIM.DISPLAY in $ANIM.LOAD
  18. \ 00002 PLB 10/25/91 Sizeof() does not need [ ] LITERAL
  19. \ 00003 PLB 11/16/91 Extensive revision for new error handlers.
  20. \ 00004 PLB 11/19/91 Don't erase ANIM-HEADER in SAVE.DELTAS
  21. \ 00005 PLB 11/19/91 Set AH_W to #pixels, not #bytes.
  22. \ 00006 PLB 1/28/92 Use 1 ANIM.GOTO.FRAME instead of ANIM.REWIND
  23.  
  24. ANEW TASK-ANIM_IFF
  25.  
  26. ANHD anim-header
  27. DPAN anim-dpan
  28. variable $anim-file
  29. variable anim-operation
  30. variable anim-interleave
  31. variable anim-bits
  32. variable anim-scanflag
  33. variable deltaptr
  34. variable seekptr
  35. variable sizeptr
  36. variable deltacount
  37.  
  38. : ANIM.READ.ANHD? ( size --- error? , read anim header )
  39.     dup sizeof() ANHD <
  40.     IF " Short AnimHeader!" cr
  41.         drop TRUE
  42.     ELSE
  43.         anim-header swap
  44.         iff.read?
  45.     THEN
  46. ;
  47.  
  48. : ANIM.PARSER ( size chkid -- , recursively parse ANIM )
  49.     2dup iff.special?
  50.     IF 2drop
  51.     ELSE ( -- size chkid )
  52.     CASE
  53.         'ANHD'
  54.         OF anim-header @ \ Is this NOT the first ANHD in the file?
  55.             IF
  56.                 anim.read.anhd? ?goto.error
  57.                 anim-header ..@ ah_operation
  58.                 anim-operation @ =
  59.                 anim-header ..@ ah_interleave
  60.                 anim-interleave @ =
  61.                 anim-header ..@ ah_bits
  62.                 anim-bits @ =
  63.                 and and
  64.                 IF-NOT anim-scanflag off
  65.                 THEN
  66.             ELSE
  67.                 anim.read.anhd? ?goto.error
  68.                 anim-header ..@ ah_operation
  69.                 anim-operation !
  70.                 anim-header ..@ ah_interleave
  71.                 anim-interleave !
  72.                 anim-header ..@ ah_bits
  73.                 anim-bits !
  74.             THEN
  75.         ENDOF
  76.         'DLTA'
  77.         OF
  78.             1 deltacount +!
  79.             drop
  80.         ENDOF
  81.     drop
  82.     ENDCASE
  83.     THEN
  84.     exit
  85. ERROR:
  86.     iff-stop on
  87.     iff-error on
  88. ;
  89.  
  90. : ANIM.HANDLER ( size chkid -- , handles ANIM specific chunks, eg. DLTA )
  91.     'DLTA' =
  92.     IF
  93.         iff.read.data deltaptr @ push
  94.     ELSE drop
  95.     THEN
  96. ;
  97.  
  98. : ANIM.DISK.HANDLER ( size chkid -- , handles ANIM specific chunks )
  99.     'DLTA' =
  100.     IF
  101.         sizeptr @ push
  102.         iff.where seekptr @ push
  103.     ELSE drop
  104.     THEN
  105. ;
  106.  
  107. : $ANIM.PREP? ( $filename --- error? )
  108.     anim-header sizeof() ANHD erase
  109.     $anim-file freevar
  110.     anim-operation off
  111.     anim-interleave off
  112.     anim-bits off
  113.     anim-scanflag ON
  114.     deltacount off
  115.     deltaptr freelist?
  116.     seekptr freevar
  117.     sizeptr freevar
  118. \
  119. \ save filename
  120.     dup c@ 1+ MEMF_PUBLIC swap allocblock
  121.     dup 0=
  122.     IF
  123.         ." No Memory for filename?" cr
  124.         2drop TRUE
  125.     ELSE
  126.         dup $anim-file !
  127.         $move
  128.         FALSE
  129.     THEN
  130. ;
  131.  
  132. : ANIM.ALLOC.YTABLE? { animatn -- error? , alloc mult table }
  133.     animatn ..@ pic_bitmap
  134.     dup ..@ bm_bytesperrow
  135.     swap ..@ bm_rows
  136.     alloc.ytable
  137.     dup animatn ..! an_ytable
  138.     0=
  139.     IF
  140.         ." No memory for anim Y-table." cr
  141.         TRUE
  142.     ELSE FALSE
  143.     THEN
  144. ;
  145.  
  146. : $ANIM.SCAN? ( $filename --- error? )
  147.     $anim.prep?
  148.     IF
  149.         TRUE
  150.     ELSE
  151.         what's iff.process.chunk
  152.         ' anim.parser is iff.process.chunk
  153.         $anim-file @ $iff.dofile?
  154.         swap is iff.process.chunk
  155.     THEN
  156.     anim-scanflag @ 0= AND  \ also incorporate this mysterious error flag
  157. ;
  158.  
  159. : $ANIM.LOAD? { $filename animatn  --- error? }
  160.     $filename $anim.scan? ?goto.error
  161. \
  162. \ validate ANIM format
  163.     anim-operation @ 5 =
  164.     anim-interleave @ 0 =
  165.     anim-bits @ 0 =
  166.     and and NOT
  167.     IF \ Bad format!
  168.         $anim-file @ $type
  169.         ." : Anim-file is not of correct format!" cr
  170.         anim-operation @ ." OP: " .
  171.         anim-interleave @ ." Interleave: " .
  172.         anim-bits @ ." Bits: " . cr
  173.         goto.error
  174.     THEN
  175. \
  176.     ilbm.init
  177.     animatn ..@ an_flags
  178.     anim_diskmode and
  179.     IF
  180. \
  181. \ disk mode alocation
  182.         MEMF_PUBLIC deltacount @ cells allocblock
  183.         dup seekptr ! 0=
  184.         MEMF_PUBLIC deltacount @ cells allocblock
  185.         dup sizeptr ! 0=
  186.         or 
  187.         IF
  188.             ." No memory for disk pointers!" cr
  189.             goto.error
  190.         THEN
  191.         ' anim.disk.handler is ilbm.other.handler
  192.     ELSE
  193. \
  194. \ memory mode allocation
  195.         MEMF_PUBLIC deltacount @ cells allocblock
  196.         dup
  197.         IF deltaptr !
  198.         ELSE
  199.             drop
  200.             " No memory for Deltas!" cr
  201.             goto.error
  202.         THEN
  203.         ' anim.handler is ilbm.other.handler
  204.     THEN
  205. \
  206. \ load initial picture
  207.     $anim-file @ animatn $pic.load?
  208.     IF
  209.         ." Not able to load ILBM" cr
  210.         goto.error
  211.     THEN
  212.     ' 2drop is ilbm.other.handler
  213. \
  214. \ make duplicate image for double buffer
  215.     animatn  dup .. an_pic1 pic.duplicate? ?goto.error
  216.     animatn  dup .. an_pic1 pic.copy
  217. \
  218. \ setup animation
  219.     anim_valid_key animatn ..! an_key
  220.     deltaptr @ animatn ..! an_deltalist
  221.     deltaptr off
  222.     deltacount @ animatn ..! an_cels
  223.     deltacount off
  224.     seekptr @ animatn ..! an_seeklist
  225.     seekptr off
  226.     sizeptr @ animatn ..! an_sizelist
  227.     sizeptr off
  228. \
  229.     ilbm-camg @ animatn ..! an_CAMG
  230.     animatn dup ..!  an_displaying
  231.     animatn .. an_pic1 animatn ..! an_hiding
  232.     0 animatn ..! an_atdelta
  233. \
  234.     animatn anim.alloc.ytable? ?goto.error
  235. \
  236. \ set filename if disk based
  237.     animatn ..@ an_flags
  238.     anim_diskmode and
  239.     IF
  240.         $anim-file @
  241.         animatn ..! an_$filename
  242.         $anim-file off
  243.     ELSE $anim-file freevar
  244.     THEN
  245.     false
  246.     exit
  247. \
  248. ERROR:
  249.     seekptr freevar
  250.     sizeptr freevar
  251.     deltaptr freevar
  252.     $anim-file freevar
  253.     true
  254. ;
  255.  
  256. : $ANIM.DISK.LOAD? ( $filename animation  --- error? )
  257.     dup ..@ an_flags anim_diskmode OR
  258.     over ..! an_flags
  259.     $anim.load?
  260. ;
  261.  
  262.  
  263. : ANIM.LOAD? ( animation <filename> -- error? )
  264.     fileword swap $anim.load?
  265. ;
  266.  
  267. : ANIM.DISK.LOAD? ( animation <file> -- error? )
  268.     fileword swap $anim.disk.load?
  269. ;
  270.  
  271. : ANIM.SAVE.DELTAS? { animatn -- error? , save delta chunks }
  272. \ This is called for for ANIMBRUSHES!!!
  273. \ Be careful about changing this!
  274.     5 anim-header ..! ah_operation
  275.     1 anim-header ..! ah_reltime
  276.     animatn ..@ pic_bitmap dup
  277.         ..@ bm_bytesperrow 8 * anim-header ..! ah_w \ 00005
  278.         ..@ bm_rows anim-header ..! ah_h
  279. \
  280.     animatn ..@ an_cels 0
  281.     DO
  282.         'ILBM' iff.begin.form? IF drop goto.error THEN
  283. \
  284.         anim-header sizeof() ANHD 'ANHD'
  285.         iff.write.chunk? IF drop goto.error THEN
  286. \
  287.         animatn ..@ an_deltalist i cells + @
  288.         dup sizemem 'DLTA'
  289.         iff.write.chunk? IF drop goto.error THEN
  290. \
  291.         iff.end.form? ?goto.error
  292.     LOOP
  293.     false
  294.     exit
  295. ERROR:
  296.     ." ANIM.SAVE.DELTAS? failed!" cr
  297.     true
  298. ;
  299.  
  300. : $ANIM.SAVE? { $filename animatn --- error? }
  301.     animatn anim.check
  302.     animatn ..@ an_flags
  303.     anim_diskmode and
  304.     IF ." Can't save DISK-MODE anim" abort \ programmer error
  305.     THEN
  306. \
  307.     1 animatn anim.goto.frame \ to generate first and second pic 00006
  308. \
  309. \ setup DPaint chunk
  310.     3 anim-dpan ..! dp_code
  311.     animatn ..@ an_cels 2- anim-dpan ..! dp_frames
  312.     15 anim-dpan ..! dp_rate
  313.     0  anim-dpan ..! dp_mode
  314.     0  anim-dpan ..! dp_dur
  315. \
  316.     $filename new $iff.open? 0= ?goto.error
  317. \
  318. \ this leaves position on stack
  319.     'ANIM' iff.begin.form? IF drop goto.error THEN
  320. \
  321. \ write initial image
  322.     animatn ..@ an_hiding >r  \ use hidden picture
  323.     r@ ..@ pic_bitmap
  324.     r@ ..@ pic_ctable
  325.     r> ..@ pic_num_colors
  326.     animatn ..@ an_CAMG
  327.     anim-dpan
  328.     ilbm.write.ilbm+camg+dpan? IF drop goto.error THEN
  329. \
  330. \ save all deltas
  331.     anim-header sizeof() ANHD erase
  332.     animatn anim.save.deltas? IF drop goto.error THEN
  333. \
  334.     iff.end.form?         ?goto.error
  335.     iff.close
  336. \
  337.     FALSE
  338.     EXIT
  339. \
  340. ERROR:
  341.     iff.close
  342.     TRUE
  343. ;
  344.  
  345. : ANIM.SAVE? ( anim <filename> --- error? )
  346.     fileword swap $anim.save?
  347. ;
  348.  
  349.  
  350.